home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / kruse_11.arc / INDEXSOR.PAS < prev    next >
Pascal/Delphi Source File  |  1990-11-30  |  31KB  |  897 lines

  1.  
  2. {outline of declaration of subprograms:
  3.  
  4.  1.     program IndexText(InText, InIndex, NewIndex, OutIndex, HashFile,
  5.                           NewHashFile, input, output);     (main program)
  6.  2.         function Lt(u, v: word):  Boolean;
  7.  3.         procedure ReadWord(var f: text;  var w: word);
  8.  4.         procedure WriteWord(var f: text; w: word);
  9.  4a.        built in CPU time function   clock;
  10.  
  11.  5.         procedure SplitWords;                       (phase 1)
  12.  5a.            function FindFile(ch: char): filecode;
  13.  6.             function HashAddress(w: word):  hashentry;
  14.  7.             procedure Initialize;
  15.  8.             procedure GetWord;
  16.  8a.                procedure TellUserPage;
  17.  9.                 procedure GetChar(var ch: char);
  18. 10.                 procedure AddChar(ch: char);
  19. 11.             procedure Conclude;
  20.  
  21. procedure ClassifyWords;
  22.     procedure InitializeTable(RefTable: RefHashTable);
  23.         function HashAddress(x: reference): integer;
  24.         procedure Insert(x: reference; pos: integer; var RefTable: RefHashTable);
  25.     procedure Place(var F: fileref; RefTable: RefHashTable);
  26.         function Empty(L: list): Boolean;
  27.     procedure LinkEntries(RefTable: RefHashTable; var NewList: list);
  28.         procedure RemoveFirst(var p: pointer; L: list);
  29.         procedure SkipBlank(var F: text);
  30.         procedure ReadReference(var r: pointer; var F: text);
  31.         procedure WriteReference(p: pointer; var NewIndex, NewHashFile: text);
  32.         procedure GetWordType(p: pointer);
  33.         procedure Delete(var p: pointer);
  34.     procedure CompareAndMerge(NewList: list;var InIndex,NewIndex,NewHashFile: text);
  35.             procedure Merge(p, q: pointer; var r: pointer);
  36.             procedure Divide(var p, q:  pointer);
  37.             procedure MergeSort(var p: pointer);
  38.         procedure MainMergeSort(var L: list);  
  39. }
  40.  
  41.  
  42. program IndexText(InText, InIndex, NewIndex, HashFile, NewHashFile,
  43.                   input, output);
  44.  
  45. {Produces word counts and list of references for the document file 
  46.  InText. Uses the master word list in file InIndex, if provided. Output word
  47.  list for new text goes to file NewIndex. HashFile contains the common words
  48.  to be ignored. If not specified, it is created on output, containing the
  49.  words so flagged by the user.}
  50. {This implementation uses only phases 1 and 2. A smaller array of text files
  51.  is also used, as specified in the exercise section.}
  52.  
  53. const
  54.   maxwd         =   20;             {More letters in word will be ignored.}
  55.   minwd         =    1;                    {Shorter words will be ignored.}
  56.   hashsize      = 2003;                                 {should be a prime}
  57.   linesperpage  =   66;                {assumes standard spacing and paper}
  58.   maxheight     =   20;               {for building binary tree in phase 2}
  59.   A             =  'A';
  60.   Z             =  'Z';
  61.   hyphen        =  '-';
  62.   blank         =  ' ';
  63.   apostrophe    = '''';               {requires two `'s  to represent one}
  64.   underscore    =  '_';
  65.   ordbackspace  =    8;            {ASCII control character for backspace}
  66.   ordformfeed   =   12;             {ASCII control character for new page}
  67.   changecase    =   32;    {ASCII difference between upper and lower case}
  68.   nfiles        =    8;  {number of temporary files for unprocessed words}
  69.   MaxRowLength  =   130;                 {maximum length of output records}
  70.  
  71. type
  72.   word          =  packed array[1..maxwd] of char;
  73.   reference     =  record
  74.                       wd:   word;
  75.                       pg:   integer;               {count or page number}
  76.                    end;
  77.   fileref       =  file of reference;              {used for local files}
  78.   letter        =  A..Z;
  79.   hashentry     =  1..hashsize;
  80.   filecode      =  1..nfiles;
  81.  
  82. var
  83.   InText,                                     {document being processed}
  84.   InIndex,                                            {master word list}
  85.   NewIndex,                              {word list of current document}
  86.   HashFile,
  87.   NewHashFile:      text;
  88.   RefFile:      array[filecode] of fileref; {local files used for auxilary
  89.                                storage of words from phase 1 to phase 2:
  90.                 Normally, a separate file exist for each initial letter,
  91.         this version uses nfiles files due operating system constraints.}
  92.   blankword:    word;                           {will contain all blanks}
  93.  
  94. {The next two variables were originally declared in procedure SplitWords,
  95.  they have been moved to this level in order to access them globally.}
  96.   outcount:     array[filecode] of integer;    {counters for word  files}
  97.   wordcount:    integer;                 {count of all words in the text}
  98.  
  99.   intextname,
  100.   inlistname,
  101.   newlistname,
  102.   newhashname:  word;                    {used to get filename from user}
  103.   lastletter:   array[filecode] of letter;     {last letter in each file}
  104.   PresentTime,
  105.   StartTime:    integer;                         {used to track CPU time}
  106.   RowLength:    integer;   {ensures records will not exceed MaxRowLength}
  107.  
  108.  
  109.  
  110. function Lt( u, v: word): Boolean;
  111. {Determains if word u precedes word v lexicographically.}
  112. begin
  113.   Lt := (u < v)
  114. end;
  115.  
  116. procedure ReadWord( var F: text;  var w: word);
  117. {Reads word w from text file F.  Assumes not at end of file.}
  118. {Uses packed array, replace using a loop if your system does not 
  119.  support packed arrays. }
  120. begin                           {procedure ReadWord}
  121.   read(F, w)
  122. end;                            {procedure ReadWord}
  123.  
  124. procedure WriteWord( var F: text; w: word);
  125. {Writes word w to text file F}
  126. {Uses packed array, replace using a loop if your system does not 
  127.  support packed arrays. }
  128. begin                           {procedure WriteWord}
  129.   write(F, w)
  130. end;                            {procedure WriteWord}
  131.  
  132. procedure SetTimer;     {Call once at beginning of program execution.}
  133. {Finds the CPU time when called, and keeps in variables for reference.}
  134. {System dependent procedure.}
  135. begin
  136.   PresentTime := clock;
  137.   StartTime := PresentTime;
  138. end;
  139.  
  140. function TotalTime:  real;
  141. {Returns the total CPU time, in seconds, since call to SetTimer.}
  142. {System dependent procedure.}
  143. begin
  144.   TotalTime := (clock - StartTime) / 1000.0;
  145. end;
  146.  
  147. function ElapsedTime:  real;
  148. {Returns elapsed CPU time since last call to function ElapsedTime,
  149.  or call to SetTimer, whichever is more recent.}
  150. {System dependent procedure.}
  151. var r: integer;
  152. begin
  153.   r := clock;
  154.   ElapsedTime := (r - PresentTime) / 1000.0;
  155.   PresentTime := r;
  156. end;
  157.  
  158.  
  159.  
  160. procedure SplitWords;
  161. {sets up hash table, reads text, and divides into nfiles word lists}
  162.  
  163. var
  164.   hash:       array[hashentry] of reference;              {hash table}
  165.   pagecount:  integer;                 {keeps the current page number}
  166.   addpage:    integer;       {amount to increase pagecount after word}
  167.   linecount:  integer;                     {lines on the current page}
  168.   w:          word;                   {word currently being processed}
  169.   x:          hashentry;             {location of w, if in hash table}
  170.   endinput:   Boolean;   {true if and only if input has all been read}
  171.   code:       filecode;                {into which file does word go?}
  172.  
  173. {The following variables are kept for use in procedure GetWord, and for
  174.  efficiency are set up only once in procedure Initialize:}
  175.   backspace,
  176.   formfeed:   char;
  177.   alphabet,                           {letters only - to start a word}
  178.   contchar:   set of char;     {other characters ok in middle of word}
  179.  
  180.  
  181.   function  FindFile( ch:  letter):  filecode;
  182.   {Uses binary decision tree to select one of nfiles = 8 files depending
  183.    on the letter ch.  These letters must be the same as those in the
  184.    global array  lastletter  .}
  185.  
  186.   begin                           {function FindFile}
  187.     if            ch < 'M' then
  188.       if          ch < 'E' then
  189.         if        ch < 'C' then  FindFile := 1
  190.                            else  FindFile := 2
  191.       else if     ch < 'H' then  FindFile := 3
  192.                            else  FindFile := 4
  193.     else if       ch < 'S' then
  194.       if          ch < 'P' then  FindFile := 5
  195.                            else  FindFile := 6
  196.       else if     ch < 'T' then  FindFile := 7
  197.                            else  FindFile := 8
  198.   end;                            {function FindFile}
  199.  
  200.  
  201.  
  202.   function HashAddress(w: word): hashentry;
  203.   {calculates the location in hash table of word w, or, if not there,
  204.    returns pointing to the blank word where w should go}
  205.  
  206.   var
  207.     x,                            {calculated location}
  208.     inc:     integer;             {increment for open addressing}
  209.   begin                           {function HashAddress}
  210.     x := abs(ord(w[1])*ord(w[2])+ord(w[4])+ord(w[6])) mod hashsize + 1;
  211. {Hash function assumes long word length. For short word machines
  212.  we must ensure that the result is non-negative, and worry about overflow.}
  213.  
  214.     if (hash[x].wd <> w) and (hash[x].wd <> blankword) then
  215.       begin
  216.         inc   := (abs(ord(w[3])-95) mod 29);
  217.                   {A key dependent increment is used to avoid clustering.}
  218.         repeat
  219.           inc := inc + 1;
  220.           if inc > hashsize then
  221.             writeln(w,' causes hash table to become full, infinite loop.');
  222.           x := x + inc;
  223.           if x > hashsize then x := x - hashsize;
  224.         until (w =  hash[x].wd)  or  (blankword = hash[x].wd)
  225.       end;
  226.     HashAddress := x
  227.   end;                            {function HashAddress}
  228.  
  229.  
  230.   procedure Initialize;
  231.   {sets up constant-valued sets for use in GetWord. Opens the text file
  232.    and initializes various counters. Opens file holding hash table (if any),
  233.    and reads or otherwise initializes table}
  234.   var
  235.     i:         integer;          {general purpose loop control}
  236.  
  237.   begin                           {procedure Initialize}
  238.     backspace:= chr(ordbackspace);
  239.     formfeed := chr(ordformfeed); {initialize ASCII control characters}
  240.     alphabet := ['A'..'Z', 'a'..'z'];      {letters only, to start a word}
  241.     contchar := [hyphen, apostrophe, backspace, underscore];
  242.                                 {characters which will not terminate word}
  243.     for i := 1 to maxwd do
  244.       blankword[i] := blank;
  245.  
  246.     write('Name of input text file?');
  247.     ReadWord(input, intextname); readln;
  248.     open(InText, intextname, readonly);
  249.     reset(InText);
  250.     endinput := eof(InText);
  251.  
  252.     repeat
  253.       write( 'What is the page number on which the text begins?');
  254.       readln(pagecount);
  255.       if pagecount < 0 then
  256.         writeln('Must be a non-negative integer.')
  257.     until pagecount >= 0;
  258.     linecount := 0;
  259.     addpage   := 0;
  260.     wordcount := 0;
  261.  
  262.     for i := 1 to nfiles do
  263.     begin
  264.       rewrite( RefFile[i] );
  265.       outcount[i] := 0
  266.     end;
  267.     lastletter[1] := 'B';
  268.     lastletter[2] := 'D';
  269.     lastletter[3] := 'G';
  270.     lastletter[4] := 'L';
  271.     lastletter[5] := 'O';
  272.     lastletter[6] := 'R';
  273.     lastletter[7] := 'S';
  274.     lastletter[8] := 'Z';
  275.  
  276.     reset(HashFile);   {assumes HASHFILE.DAT is in current directory}
  277.  
  278.     for i := 1 to hashsize do
  279.     with hash[i] do 
  280.       begin
  281.         read(HashFile, pg);
  282.         get(HashFile);         {skip the blank between number and word}
  283.         ReadWord(HashFile, wd);
  284.         readln(HashFile);
  285.         pg := 0;                     {initialize all the counts to 0}
  286.       end;
  287.     writeln('The hash table has been read.')
  288.   end;                                        {procedure Initialize}
  289.  
  290.  
  291.  
  292.   procedure GetWord( var  w: word);
  293.   {Gets words from input file InText, and returns only words
  294.    at least minwd characters long.  Parameter endinput becomes
  295.    true if and only if the end of InText is reached with no word to return.
  296.    the procedure also updates global variables wordcount and linecount,
  297.    updates the global variable pagecount after each linesperpage cr's,
  298.    or after each formfeed, whichever comes first, and
  299.    uses the sets alphabet and contchar and various character constants.}
  300.  
  301.   label 1;           {used by GetChar to exit procedure upon eof(InText)}
  302.  
  303.   var  c:      0..maxwd;                    {count of characters in word}
  304.        ch:     char;                      {character currently processed}
  305.        endln:  Boolean;                           {at the end of a line?}
  306.  
  307.  
  308.   procedure TellUserPage;         {keep the user informed of progress}
  309.   var   i: integer;
  310.   begin
  311.     i := pagecount + addpage;
  312.     writeln('At page', i:4, ' word count is', wordcount:7)
  313.   end;
  314.  
  315.  
  316.   procedure GetChar(var ch: char);
  317.   {gets a character from input text into ch; checks for eof; updates
  318.    page count and line count}
  319.  
  320.   begin                                                {procedure GetChar}
  321.     if eof(InText) then
  322.       if c >= minwd then
  323.         ch := '.'              {special character to end the current word}
  324.       else begin                         {no word to return; set endinput}
  325.         endinput := true;
  326.         goto 1                                        {exit from GetWord.}
  327.       end
  328.     else begin                   {not end of file: process next character}
  329.       while InText^ in [underscore, backspace] do
  330.         get( InText);
  331.       ch := InText^;
  332.       endln := eoln(InText);
  333.       get(InText);
  334.       if endln then
  335.       begin
  336.         linecount := linecount + 1;
  337.         if linecount >= linesperpage then
  338.           begin
  339.             addpage := addpage + 1;
  340.             linecount := 0;
  341.             TellUserPage
  342.           end
  343.       end;
  344.       if ch = formfeed then
  345.         begin
  346.           addpage := addpage + 1;
  347.           linecount := 0;
  348.           TellUserPage;
  349.           endln := true;            {Treat formfeed like end of line.}
  350.           ch := blank
  351.         end
  352.     end
  353.   end;                                            {procedure GetChar}
  354.  
  355.  
  356.   procedure AddChar(ch: char);
  357.   {adds given character to word, if possible}
  358.   begin                           {procedure AddChar}
  359.     if c < maxwd then
  360.     begin
  361.       c := c + 1;
  362.       w[c] := ch
  363.     end
  364.   end;                            {procedure AddChar}
  365.  
  366.  
  367.   begin                           {procedure GetWord}
  368.     repeat                {until current word is at least minwd chars long}
  369.       c := 0;
  370.       repeat
  371.         GetChar(ch)               {Find a letter which will start the word.}
  372.       until ch in alphabet;
  373.       pagecount := pagecount + addpage;
  374.       addpage := 0;
  375.       if ch in ['a'..'z'] then       {translate first letter to upper case.}
  376.         ch := chr(ord(ch) - changecase); {assumes ASCII ordering of letters}
  377.       AddChar(ch);                          {put first letter into the word}
  378.       GetChar(ch);
  379.       while (ch in alphabet) or (ch in contchar) do
  380.         if ch in alphabet then                {add letters directly to word}
  381.         begin                                            {processing letter}
  382.           AddChar(ch);
  383.           GetChar(ch)
  384.         end                                              {processing letter}
  385.         else if ch = hyphen then
  386.         begin                                            {processing hyphen}
  387.           GetChar(ch);                       {Find what comes after hyphen.}
  388.           if endln then
  389.             while ch = ' ' do
  390.               GetChar(ch)       {Delete both the hyphen and the end of line}
  391.           else if ch = hyphen then      {Two hyphens form a dash; ends word}
  392.             ch := blank                 {Use a blank to terminate the word.}
  393.           else if ch in alphabet then
  394.             AddChar(hyphen)                  {Include other hyphens in word}
  395.           else      {nothing}
  396.         end                                              {processing hyphen}
  397.         else if ch = apostrophe then
  398.         begin                                        {processing apostrophe}
  399.           GetChar(ch);
  400.           if ch = 's' then              {Delete  `'s'   at end of word only}
  401.           begin
  402.             GetChar(ch);
  403.             if ch in contchar then
  404.             begin
  405.               AddChar(apostrophe);
  406.               AddChar('s')
  407.             end
  408.           end
  409.           else if ch in alphabet then
  410.              AddChar(apostrophe)                      {Allow contractions.}
  411.         end                                         {processing apostrophe}
  412.         else         {Remaining possibilities are backspace and underscore.}
  413.           GetChar(ch);                           {Delete these characters.}
  414.       {While loop on continuing characters ends here.}
  415.       wordcount := wordcount + 1
  416.     until c >= minwd;                              {Skip over short words.}
  417.  
  418.     while c < maxwd do                                  {Fill with blanks.}
  419.     begin
  420.       c := c + 1;
  421.       w[c] := blank
  422.     end;
  423.   1:      {When end of file occurs, program will exit to here from GetChar}
  424.   end;                                                  {procedure GetWord}
  425.  
  426.  
  427.  
  428. procedure Conclude;
  429. {Writes out counts of various word lists. For some systems, it is 
  430.  necessary to close files, which should be done here.}
  431.  
  432. var
  433.   i,j:        integer;                                {loop index}
  434.   response:   char;                    {user's answer to question}
  435.  
  436. begin                           {procedure Conclude}
  437.   writeln('The total number of words read in is ', wordcount:7);
  438.   writeln;
  439.   writeln('The number of words to process further in the next stage,');
  440.   writeln('in each temporary file, is below.');
  441.   writeln('     a-b     c-d     e-g     h-l     m-o     p-r      s      t-z');
  442.   for i := 1 to nfiles do
  443.     write(outcount[i]:8);
  444.   writeln;
  445.   writeln;
  446.  
  447. (*                    not implemented:
  448.   repeat
  449.     write('Do you wish the counts from hash table to be kept in a file (y,n)?');
  450.     readln(response);
  451.     if response > 'Z' then response := chr(ord(response)-changecase)
  452.   until response in ['N', 'Y'];
  453.   if response = 'Y' then
  454.   begin
  455.  
  456.     write('Name of file ?');
  457.     ReadWord(input, newhashname);
  458.     readln;
  459.     open(NewHashFile, newhashname);
  460.     rewrite(NewHashFile);
  461.  
  462.     for i := 1 to hashsize do
  463.     with hash[i] do begin
  464.       write(NewHashFile, pg:4, ' ');
  465.       j := 1;
  466.       repeat
  467.         write(NewHashFile, wd[j]);
  468.         j := j + 1;
  469.       until (wd[j] = ' ') or (j >= maxwd);
  470.       writeln(NewHashFile)
  471.     end
  472.   end                 *)
  473. end;                            {procedure Conclude}
  474.  
  475.  
  476. begin                                          {procedure  SplitWords}
  477.   Initialize;                   {sets up files, hash table, constants}
  478.   GetWord(w);                       {obtain a single word from InText}
  479.   while not endinput do
  480.   begin
  481.     x := HashAddress(w);
  482.     if w = hash[x].wd then
  483.       hash[x].pg := hash[x].pg + 1
  484.     else begin                  {not in hash table; put into RefFile}
  485.       code := FindFile( w[1] );
  486.       outcount[code] := outcount[code] + 1;
  487.       with RefFile[code]^ do
  488.       begin
  489.         wd := w;
  490.         pg := pagecount
  491.       end;
  492.       Put(RefFile[code])
  493.     end;
  494.     GetWord(w)
  495.   end;
  496.   Conclude                           {writes word counts to output.}
  497. end;                                          {procedure SplitWords}
  498.  
  499.  
  500.  
  501.  
  502. {start of phase 2}
  503.  
  504. procedure ClassifyWords;
  505. {The references stored in the temporary files are placed in a new hash table,
  506.  the words from the file InIndex are compared with the words in the new table
  507.  as they are merged into the file NewIndex.}
  508.  
  509. type
  510.   wordtype  = (hash, count, index);          {ways to process a word}
  511.   pointref  = ^reflist;
  512.   reflist   = record                            {list of references}
  513.                 pg:   integer;
  514.                 next: pointref
  515.               end;
  516.   pointer   = ^node;
  517.   node      = record                     {node of list storing wrods.}
  518.                 wd:       word;
  519.                 kind:     wordtype;
  520.                 ct:       integer;
  521.                 ref:      pointref;
  522.                 next:     pointer
  523.               end;
  524.        {Cannot use varying types as @wordtype is not known upon first reading.}
  525.   list = record
  526.            head:  pointer
  527.          end;
  528.  
  529. var
  530.   code:       filecode;          {loop through temporary files}
  531.   NewList:    list;
  532.  
  533. (*=====================================================================*)
  534. function Empty(L: list): Boolean;
  535. begin
  536.   Empty := (L.head = nil)
  537. end;
  538. (*=====================================================================*)
  539.  
  540. procedure Merge(p, q: pointer; var r: pointer);
  541. {Merges two sorted lists into one, that will begin at r;
  542.  requires that both lists be non empty.  This version is modified 
  543.  slightly from the version listed in the text due to a difference 
  544.  in the data structures used.}
  545. var
  546.   s:  pointer;     {always points to last node of sorted list}
  547. begin                                  {procedure Merge}
  548.   if (p = nil) or (q = nil) then
  549.     writeln('Merge called with empty list(s).');
  550.   {First find the head, r, of the merged list.}
  551.   if p^.wd <= q^.wd then                   {change .info.key to .wd}
  552.   begin
  553.     r := p;
  554.     p := p^.next
  555.   end
  556.   else begin
  557.     r := q;
  558.     q := q^.next
  559.   end;
  560.   s := r;       {s always points to the last entry of the merged list.}
  561.   while (p <> nil) and (q <> nil) do
  562.     if p^.wd <= q^.wd then                   {change .info.key to .wd}
  563.     begin
  564.       s^.next := p; {Attach the node with the smaller key to the sorted list.}
  565.       s := p;
  566.       p := p^.next      {Advance to the next unmerged node.}
  567.     end
  568.     else begin
  569.       s^.next := q;
  570.       s := q;
  571.       q := q^.next
  572.     end;
  573.   {After one list is exhausted, attach the remainder of the other one.}
  574.   if p = nil then
  575.     s^.next := q
  576.   else
  577.     s^.next := p
  578. end;                                     {procedure Merge}
  579.  
  580. (*===========================================================================*)
  581. procedure Divide(var p, q:  pointer);
  582. {takes the list to which p points, divides it in half, and returns with
  583.  p pointing to head of the first half and q to the head of second half;
  584.  requires that the original list contain at least two items, or an 
  585.  error occurs}
  586. var
  587.   r:  pointer;
  588. begin                                      {procedure Divide}
  589.   q := p;                 {Start q at position 1, and r at position 3.}
  590.   r := p^.next;
  591.   r := r^.next;
  592.   while r <> nil do       {Move r two positions for each move of q.}
  593.   begin
  594.     r := r^.next;
  595.     q := q^.next;
  596.     if r <> nil then
  597.       r := r^.next
  598.   end;
  599.   {Break the list into halves after q^.}
  600.   r := q^.next;
  601.   q^.next := nil;
  602.   q := r
  603. end;                                    {procedure Divide}
  604.  
  605. procedure MergeSort(var p: pointer);
  606. {divides the list starting at p^ in half, sorts it recursively, and merges
  607.  the sublists}
  608. var
  609.   q:  pointer;          {marks the halfway point in the list}
  610. begin
  611.   if p <> nil then if p^.next <> nil then
  612.   begin   {Otherwise, list has 0 or 1 entry, with no need to sort.}
  613.     Divide(p, q);
  614.     MergeSort(p);
  615.     MergeSort(q);
  616.     Merge(p, q, p)
  617.   End
  618. End;
  619. (*===========================================================================*)
  620.  
  621. procedure MainMergeSort(var L: list);
  622. { Main procedure to invoke recursive procedure @MergeSort, as listed 
  623.   in the text. }
  624. begin
  625.   MergeSort(L.head)
  626. end;
  627.  
  628. procedure InitializeList(var L: list);
  629. begin
  630.   L.head := nil
  631. end;
  632.  
  633.  
  634. procedure Insert(x: reference; var L: list);
  635. { Inserts the reference into the hash table of references. }
  636. var
  637.   done:  Boolean;
  638.   p:  pointer;
  639.   q:  pointref;
  640. begin                                 {procedure Insert}
  641.   done := false;
  642.   p := L.head;
  643.   while (p <> nil) and (not done) do
  644.   begin
  645.     if p^.wd = x.wd then
  646.     begin
  647.       p^.ct := p^.ct + 1;
  648.       new(q);
  649.       q^.pg := x.pg;
  650.       q^.next := p^.ref;
  651.       p^.ref := q;
  652.       done := true
  653.     end
  654.     else
  655.       p := p^.next
  656.   end;
  657.   if not done then
  658.   begin            {Insert a new entry if the word is not already in the table.}
  659.     p := nil;
  660.     new(p);
  661.     p^.wd := x.wd;
  662.     p^.ct := 1;                 {Initialize the count and the page references.}
  663.     new(q);
  664.     q^.pg := x.pg;
  665.     q^.next := nil;
  666.     p^.ref := q;
  667.     p^.next := L.head;
  668.     L.head := p
  669.   end
  670. end;                                  {procedure Insert}
  671.  
  672.  
  673. procedure Append(p: pointer; var L: list);
  674. var
  675.   q: pointer;
  676. begin                                {procedure Append}
  677.   q := L.head;
  678.   if q = nil then
  679.     L.head := p
  680.   else begin
  681.     while q^.next <> nil do
  682.       q := q^.next;
  683.     q^.next := p
  684.   end
  685. end;                                 {procedure Append}
  686.  
  687.  
  688. procedure Place(var F: fileref; var L: list);
  689. { Places the words in file @F into the list of words. }
  690. var
  691.   x:  reference;
  692.   temp:  pointer;
  693. begin                            {procedure Place}
  694.   temp := L.head;
  695.   L.head := nil;
  696.   reset(F);
  697.   while not eof(F) do
  698.   begin
  699.     x := F^;
  700.     get(F);
  701.     Insert(x, L)
  702.   end;
  703.   MainMergeSort(L);
  704.   Append(temp, L)
  705. end;                             {procedure Place}
  706.  
  707.  
  708. procedure RemoveFirst(var p: pointer; var L: list);
  709. { Removes the first node from the list @L. }
  710. begin
  711.   p := L.head;
  712.   if not Empty(L) then
  713.   begin
  714.     L.head := L.head^.next;
  715.     p^.next := nil
  716.   end
  717. end;
  718.  
  719.  
  720. procedure ReadReference(var r: pointer; var F: text);
  721. { Reads refernce from the file @F.  }
  722. var
  723.   k:  char;
  724. begin                                  {procedure ReadReference}
  725.   if eof(F) then
  726.     r := nil
  727.   else begin
  728.     ReadWord(F, r^.wd);
  729.     readln(F, k);
  730.     case  k  of
  731.       'F', 'f':  r^.kind := hash;
  732.       'C', 'c':  begin
  733.                    r^.kind := count;
  734.                    r^.ct := 0
  735.                  end;
  736.       'I', 'i':  begin
  737.                    r^.kind := index;
  738.                    r^.ref := nil
  739.                  end
  740.     end
  741.   end
  742. end;                                   {procedure ReadReference}
  743.  
  744.  
  745. procedure WriteReference(p: pointer;  var NewIndex, NewHashFile: text);
  746. var
  747.   q:  pointref;
  748. begin                                 {procedure WriteReference}
  749.   with p^ do
  750.     case kind of
  751.       hash: begin
  752.               WriteWord(NewHashFile, wd);
  753.               writeln(NewHashFile)
  754.             end;
  755.       count:begin
  756.               WriteWord(NewIndex, wd);
  757.               write(NewIndex, 'c');
  758.               writeln(NewIndex, ct:5)
  759.             end;
  760.       index:begin
  761.               WriteWord(NewIndex, wd);
  762.               write(NewIndex, 'i');
  763.               q := ref;
  764.               while q <> nil do
  765.               begin
  766.                 write(NewIndex, q^.pg:5);
  767.                 q := q^.next
  768.               end;
  769.               writeln(NewIndex)
  770.             end
  771.     end
  772. end;                                  {procedure WriteReference}
  773.  
  774.  
  775. procedure GetWordType(p: pointer);
  776. { Request the user to specify the category of the given word. }
  777. var
  778.   response: char;
  779. begin                       {procedure GetWordType}
  780.   with p^ do
  781.   begin
  782.     repeat
  783.       WriteWord(output, wd);
  784.       write(' is (F, C, I)?');
  785.       readln(response)
  786.     until response in ['F', 'f', 'C', 'c', 'I', 'i'];
  787.     case response of
  788.       'F', 'f': kind := hash;
  789.       'C', 'c': kind := count;
  790.       'I', 'i': kind := index
  791.     end
  792.   end
  793. end;                        {procedure GetWordType}
  794.  
  795.  
  796. procedure Delete(var p: pointer);
  797. { Delete the word @p^ as well as all of the page references associated with it. }
  798. var
  799.   q, r:  pointref;
  800. begin                                 {procedure Delete}
  801.   if p^.kind = index then
  802.   begin
  803.     q := p^.ref;
  804.     while q <> nil do
  805.     begin                   {dispose the reference list}
  806.       r := q^.next;
  807.       dispose(q);
  808.       p^.ref := r;
  809.       q := r
  810.     end
  811.   end;
  812.   dispose(p)            {dispose the node itself}
  813. end;                                  {procedure Delete}
  814.  
  815.  
  816. procedure CompareAndMerge(var L: list; var InIndex, NewIndex, NewHashFile: text);
  817. { Compare the list @NewList with @InIndex, merge if was found. }
  818. var
  819.   p, r:  pointer;
  820. begin                              {procedure CompareAndMerge}
  821.   RemoveFirst(p, L);
  822.   new(r);
  823.   ReadReference(r, InIndex);
  824.   while (p <> nil) do
  825.     if r = nil then
  826.     begin
  827.       GetWordType(p);
  828.       WriteReference(p, NewIndex, NewHashFile);
  829.       Delete(p);               {Remove reference list and node from memory.}
  830.       RemoveFirst(p, L)
  831.     end
  832.     else if p^.wd < r^.wd then
  833.     begin
  834.       GetWordType(p);
  835.       WriteReference(p, NewIndex, NewHashFile);
  836.       Delete(p);               {Remove reference list and node from memory.}
  837.       RemoveFirst(p, L)
  838.     end
  839.     else if p^.wd > r^.wd then     {do not write word not used to NewIndex}
  840.       ReadReference(r, InIndex)
  841.     else begin {p^.wd = r^.wd}
  842.       p^.kind := r^.kind;
  843.       WriteReference(p, NewIndex, NewHashFile);
  844.       Delete(p);               {Remove reference list and node from memory.}
  845.       RemoveFirst(p, L);
  846.       ReadReference(r, InIndex)
  847.     end
  848. end;                               {procedure CompareAndMerge}
  849.  
  850.  
  851. begin                            {procedure ClassifyWords}
  852.  
  853.   write('Name of input word list ?');
  854.   ReadWord(input, inlistname);
  855.   readln;
  856.   open(InIndex, inlistname, readonly);   {may vary on different systems}
  857.   reset(InIndex);
  858.  
  859.   write('Name of output word list ?');
  860.   ReadWord(input, newlistname);
  861.   readln;
  862.   open(NewIndex, newlistname);         {may vary on different systems}
  863.   rewrite(NewIndex);
  864.  
  865.   write('Name of file for new hash words ?');
  866.   ReadWord(input, newhashname);
  867.   readln;
  868.   open(NewHashFile, newhashname);         {may vary on different systems}
  869.   rewrite(NewHashFile);
  870.  
  871.   InitializeList(NewList);
  872.   for code := nfiles downto 1 do
  873.     Place(RefFile[code], NewList);
  874.   if not Empty(NewList) then
  875.     CompareAndMerge(NewList, InIndex, NewIndex, NewHashFile);
  876.   close(InIndex);         {may vary on different systems}
  877.   close(NewIndex);
  878.   close(NewHashFile)
  879. end;                             {procedure ClassifyWords}
  880.  
  881.  
  882.  
  883. begin                                                    {main program}
  884.   SetTimer;
  885.   SplitWords;                                                 {Phase 1}
  886.   writeln('Time in first phase is ', ElapsedTime:7:1, '   seconds.');
  887.   writeln;
  888.  
  889.   ClassifyWords;                                              {Phase 2}
  890.   writeln('Time in second phase is', ElapsedTime:7:1, '  seconds.');
  891.  
  892.   writeln;
  893.   writeln('Processing of input document ', intextname, '  is complete.');
  894.   writeln('Total time in program was ', TotalTime:7:1, '   seconds.')
  895. end.
  896.  
  897.